home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / transs.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  22.8 KB  |  709 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module transs)
  13.  
  14. (defun set-up-translate ()
  15.   (load '|<macsym>transl.autolo|)
  16.   (load '|<macsym>trdata.fasl|)
  17.   (load '|<maxout>dcl.fasl|)
  18.   (load '|<macsym>transl.fasl|)
  19.   (load '|<macsym>trans1.fasl|)
  20.   (load '|<macsym>troper.fasl|)
  21.   (load '|<macsym>trutil.fasl|)
  22.   (load '|<macsym>trans2.fasl|))
  23.  
  24. (TRANSL-MODULE TRANSS)
  25.  
  26.  
  27. (DEFMVAR *TRANSL-FILE-DEBUG* NIL
  28.     "set this to T if you don't want to have the temporary files
  29.     used automaticaly deleted in case of errors.")
  30.  
  31. ;;; User-hacking code, file-io, translator toplevel.
  32. ;;; There are various macros to cons-up filename TEMPLATES
  33. ;;; which to mergef into. The filenames are should be the only
  34. ;;; system dependant part of the code, although certain behavior
  35. ;;; of RENAMEF/MERGEF/DELETEF is assumed.
  36.  
  37. (defmvar $TR_OUTPUT_FILE_DEFAULT '$TRLISP
  38.      "This is the second file name to be used for translated lisp
  39.      output.")
  40.  
  41. (DEFMVAR $TR_FILE_TTY_MESSAGESP nil
  42.      "It TRUE messages about translation of the file are sent
  43.      to the TTY also.")
  44.  
  45. (DEFMVAR $TR_WINDY T
  46.      "Generate helpful comments and programming hints.")
  47.  
  48. (DEFTRVAR *TRANSLATION-MSGS-FILES* NIL
  49.     "Where the warning and other comments goes.")
  50.  
  51. (DEFTRVAR $TR_VERSION (GET 'TRANSL-AUTOLOAD 'VERSION))
  52.  
  53. (DEFMVAR TRANSL-FILE NIL "output stream of $COMPFILE and $TRANSLATE_FILE")
  54.  
  55. (DEFMVAR $COMPGRIND NIL "If TRUE lisp output will be pretty-printed.")
  56.  
  57. (DEFMVAR $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED nil
  58.      "This is set by TRANSLATE_FILE for use by user macros
  59.      which want to know the name of the source file.")
  60.  
  61. (DEFMVAR $TR_STATE_VARS
  62.      '((MLIST) $TRANSCOMPILE $TR_SEMICOMPILE
  63.        #+cl
  64.        $TRANSLATE_FAST_ARRAYS
  65.        $TR_WARN_UNDECLARED
  66.        $TR_WARN_MEVAL
  67.        $TR_WARN_FEXPR
  68.        $TR_WARN_MODE
  69.        $TR_WARN_UNDEFINED_VARIABLE
  70.        $TR_FUNCTION_CALL_DEFAULT 
  71.        $TR_ARRAY_AS_REF
  72.        $TR_NUMER
  73.        $DEFINE_VARIABLE))
  74.  
  75. (defmacro compfile-outputname-temp () 
  76. ;  #-(or Multics Cl) ''|_CMF_ OUTPUT|
  77.   #+Multics ''(f* _cmf_ output)
  78.   #+cl '`,(pathname "_cmf_"))
  79.  
  80. (defmacro compfile-outputname ()
  81.   #-(or Multics Cl)'`((DSK ,(STATUS UDIR))
  82.           ,(STATUS USERID)
  83.           ,(stripdollar $TR_OUTPUT_FILE_DEFAULT))
  84.   #+Multics '`(,(status udir) ,(stripdollar $tr_output_file_default))
  85.   #+cl '`,(pathname (stripdollar $tr_output_file_default)))
  86.  
  87. (defmacro trlisp-inputname-d1 ()
  88.   ;; so hacks on DEFAULTF will not stray the target.
  89.   #-(or Multics Cl) '`((dsk ,(status udir)) * >)
  90.   #+Multics '`(,(status udir) * *)
  91.   #+cl '`,(pathname ""))
  92.  
  93. (defmacro trlisp-outputname-d1 ()
  94.   #-(or Multics Cl) '`((* *)  * ,(stripdollar $TR_OUTPUT_FILE_DEFAULT))
  95.   #+Multics '`(* * ,(stripdollar $tr_output_file_default))
  96.   #+cl '`,(pathname (stripdollar $tr_output_file_default))) 
  97.  
  98. (defmacro trlisp-outputname () 
  99. ;  #-(or Multics Cl) ''|* TRLISP|
  100.   #+Multics ''(* * lisp)
  101.   #+cl '`,(make-pathname :type "LISP"))
  102.  
  103. (defmacro trlisp-outputname-temp ()
  104. ;  #-(or Multics Cl) ''|* _TRLI_|
  105.   #+Multics ''(* * _trli_)
  106.   #+cl '`,(pathname "_trli_"))
  107.  
  108. (defmacro trtags-outputname () 
  109. ;  #-(or Multics Cl) ''|* TAGS|
  110.   #+Multics ''(* * tags)
  111.   #+cl '`,(pathname "tags"))
  112.  
  113. (defmacro trtags-outputname-temp ()
  114. ;  #-(or Multics Cl) ''|* _TAGS_|
  115.   #+Multics ''(* * _tags_)
  116.   #+cl '`,(pathname "_tags_"))
  117.  
  118.  
  119. (defmacro trcomments-outputname () 
  120. ;  #-(or Multics Cl) ''|* UNLISP|
  121.   #+Multics ''(* * unlisp)
  122.   #+cl '`,(pathname "unlisp"))
  123.  
  124. (defmacro trcomments-outputname-temp () 
  125. ;  #-(or Multics Cl) ''|* _UNLI_|
  126.   #+Multics ''(* * _unli_)
  127.   #+cl '`,(pathname "_unli_"))
  128.  
  129. (DEFTRVAR DECLARES NIL)
  130. ;;;these first five functions have been altered to run on 
  131. ;;;the 3600 we must try to fix translate-file  wfs fixed -wfs
  132. #+cl
  133. (defmacro mytruename (x) `(truename ,x))
  134.  
  135.  
  136. #+cl    
  137. (defun rename-tf (new-name true-in-file-name &optional newname)
  138.    true-in-file-name  new-name
  139.   (let ((in-file))
  140.     (progn
  141.       (setq in-file (truename transl-file))
  142.       (close transl-file)
  143.       (setq newname (sub-seq (string newname) 1))
  144.       (rename-file in-file newname))))
  145.  
  146.     
  147. #+CL
  148. (DEFMSPEC $COMPFILE (FORMS)
  149.   (let (( newname (second  forms)))
  150.   (setq forms (cdr forms))
  151.   (bind-transl-state
  152.    (SETQ $TRANSCOMPILE T
  153.      *IN-COMPFILE* T)
  154.    (let ((OUT-FILE-NAME (COND ((MFILENAME-ONLYP (CAR FORMS))
  155.                     ($FILENAME_MERGE (POP FORMS)))
  156.                   (T "")))
  157.      (t-error nil)
  158.      (*TRANSLATION-MSGS-FILES* NIL))
  159.      (SETQ OUT-FILE-NAME
  160.        (MERGEF OUT-FILE-NAME (COMPFILE-OUTPUTNAME)))
  161.      (UNWIND-PROTECT
  162.       (PROGN
  163.        (SETQ TRANSL-FILE (OPEN-out-dsk (MERGEF (COMPFILE-OUTPUTNAME-TEMP)
  164.                            OUT-FILE-NAME)))
  165.  
  166.        (COND ((OR (MEMQ '$ALL FORMS) (MEMQ '$FUNCTIONS FORMS))
  167.           (SETQ FORMS (MAPCAR #'CAAR (CDR $FUNCTIONS)))))
  168.        (DO ((L FORMS (CDR L)) 
  169.         (DECLARES NIL NIL)
  170.         (TR-ABORT NIL NIL)
  171.         (ITEM) (LEXPRS NIL NIL) (FEXPRS NIL NIL)
  172.         (T-ITEM))                ;
  173.        ((NULL L))
  174.      (SETQ ITEM (CAR L))
  175.      (COND ((NOT (ATOM ITEM))
  176.         (PRINT* (DCONVX (TRANSLATE ITEM))))
  177.            (T
  178.         (SETQ T-ITEM
  179.               (COMPILE-FUNCTION
  180.                (SETQ ITEM ($VERBIFY ITEM))))
  181.         (COND (TR-ABORT
  182.                (SETQ T-ERROR
  183.                  (PRINT-ABORT-MSG ITEM
  184.                           'COMPFILE)))
  185.               (T
  186.                (COND ($COMPGRIND
  187.                   (MFORMAT TRANSL-FILE
  188.                        "~2%;; Function ~:@M~%" ITEM)))
  189.                (PRINT* T-ITEM))))))
  190.        (setq out-file-name (RENAME-TF OUT-FILE-NAME NIL newname))
  191.        (TO-MACSYMA-NAMESTRING OUT-FILE-NAME))
  192.       ;; unwind-protected
  193.       (IF TRANSL-FILE (CLOSE TRANSL-FILE))
  194.       (IF T-ERROR (DELETEF TRANSL-FILE)))))))
  195. #-cl
  196.  
  197. (DEFMSPEC $COMPFILE (FORMS) (setq forms (cdr forms))
  198.   (bind-transl-state
  199.    (SETQ $TRANSCOMPILE T
  200.      *IN-COMPFILE* T)
  201.    (let ((OUT-FILE-NAME (COND ((MFILENAME-ONLYP (CAR FORMS))
  202.                    ($FILENAME_MERGE (POP FORMS)))
  203.                   (T "")))
  204.      (t-error nil)
  205.      (*TRANSLATION-MSGS-FILES* NIL))
  206.      (SETQ OUT-FILE-NAME
  207.        (MERGEF OUT-FILE-NAME (COMPFILE-OUTPUTNAME)))
  208.      (UNWIND-PROTECT
  209.       (PROGN
  210.        (SETQ TRANSL-FILE (OPEN-out-dsk (MERGEF (COMPFILE-OUTPUTNAME-TEMP)
  211.                            OUT-FILE-NAME)))
  212.  
  213.        (COND ((OR (MEMQ '$ALL FORMS) (MEMQ '$FUNCTIONS FORMS))
  214.           (SETQ FORMS (MAPCAR #'CAAR (CDR $FUNCTIONS)))))
  215.        (DO ((L FORMS (CDR L)) 
  216.         (DECLARES NIL NIL)
  217.         (TR-ABORT NIL NIL)
  218.         (ITEM) (LEXPRS NIL NIL) (FEXPRS NIL NIL)
  219.         (T-ITEM))
  220.        ((NULL L))
  221.      (SETQ ITEM (CAR L))
  222.      (COND ((NOT (ATOM ITEM))
  223.         (PRINT* (DCONVX (TRANSLATE ITEM))))
  224.            (T
  225.         (SETQ T-ITEM
  226.               (COMPILE-FUNCTION
  227.                (SETQ ITEM ($VERBIFY ITEM))))
  228.         (COND (TR-ABORT
  229.                (SETQ T-ERROR
  230.                  (PRINT-ABORT-MSG ITEM
  231.                           'COMPFILE)))
  232.               (T
  233.                (COND ($COMPGRIND
  234.                   (MFORMAT TRANSL-FILE
  235.                        "~2%;; Function ~:@M~%" ITEM)))
  236.                (PRINT* T-ITEM))))))
  237.        (RENAME-TF OUT-FILE-NAME NIL)
  238.        (TO-MACSYMA-NAMESTRING OUT-FILE-NAME))
  239.       ;; unwind-protected
  240.       (IF TRANSL-FILE (CLOSE TRANSL-FILE))
  241.       (IF T-ERROR (DELETEF TRANSL-FILE))))))
  242.  
  243.  
  244. (DEFUN COMPILE-FUNCTION (F)
  245.        (MFORMAT  *TRANSLATION-MSGS-FILES*
  246.          "~%Translating ~:@M" F)
  247.        (LET ((FUN (TR-MFUN F)))
  248.         (COND (TR-ABORT  NIL)
  249.           (T FUN))))
  250.  
  251. (DEFVAR TR-DEFAULTF NIL
  252.     "A default only for the case of NO arguments to $TRANSLATE_FILE")
  253.  
  254. ;;; Temporary hack during debugging of this  code.
  255. #+cl
  256. (progn 'compile
  257. #-cl
  258. (defun mergef (x y) (fs:merge-pathnames y x))
  259. #+cl
  260. (defun mergef (x y) (merge-pathnames y x))
  261. #-cl
  262. (defmacro truename (x) `(send ,x ':truename)))
  263.  
  264. (defun $compile_file (input-file
  265.               &optional bin-file  translation-output-file &aux result )
  266.   (setq input-file (maxima-string input-file))
  267.   (and bin-file(setq  bin-file (maxima-string bin-file)))
  268.   (and translation-output-file
  269.        (setq  translation-output-file (maxima-string translation-output-file)))
  270.   (cond ((string-equal (pathname-type input-file) "LISP")
  271.      (setq result (list '(mlist) input-file)))
  272.     (t (setq result (translate-file input-file translation-output-file))
  273.        (setq input-file (third result))))
  274.   #+(or cmu clisp)
  275.   (multiple-value-bind (output-truename warnings-p failure-p)
  276.       (compile-file input-file :output-file (or bin-file t))
  277.     ;; If the compiler encountered errors, don't set bin-file to
  278.     ;; indicate that we found errors. Is this what we want?
  279.     (unless failure-p
  280.       (setq bin-file output-truename)))
  281.   #-(or cmu clisp)
  282.   (setq bin-file (compile-file input-file :output-file bin-file))
  283.   (append result (list bin-file)))
  284.  
  285. #-cl
  286. (DEFMFUN $TRANSLATE_FILE (&OPTIONAL (INPUT-FILE-NAME NIL I-P)
  287.                     (OUTPUT-FILE-NAME NIL O-P))
  288.      #+cl
  289.      (progn (cond ((atom input-file-name)
  290.                (setq input-file-name
  291.                  (string-trim "&" input-file-name)))))
  292.      (OR I-P TR-DEFAULTF
  293.          (MERROR "Arguments are input file and optional output file~
  294.              ~%which defaults to second name LISP, msgs are put~
  295.              ~%in file with second file name UNLISP"))
  296.      (COND (I-P
  297.         #+cl(SETQ INPUT-FILE-NAME
  298.                  (pathname
  299.                    input-file-name))
  300.         #-cl
  301.         (SETQ INPUT-FILE-NAME (MERGEF ($FILENAME_MERGE INPUT-FILE-NAME)
  302.                           (trlisp-inputname-d1)))
  303.         (SETQ TR-DEFAULTF INPUT-FILE-NAME))
  304.            (T
  305.         (SETQ TR-DEFAULTF INPUT-FILE-NAME)))
  306.      #+cl
  307.      (SETQ OUTPUT-FILE-NAME
  308.            (progn (setq output-file-name
  309.                 (pathname
  310.                   (if o-p output-file-name input-file-name)))
  311.               (send output-file-name :new-type :lisp)))
  312.      #-cl
  313.      (SETQ OUTPUT-FILE-NAME
  314.            (IF O-P
  315.            (MERGEF ($FILENAME_MERGE OUTPUT-FILE-NAME) INPUT-FILE-NAME)
  316.            (MERGEF (TRLISP-OUTPUTNAME-D1) INPUT-FILE-NAME)))
  317.      (TRANSLATE-FILE  INPUT-FILE-NAME
  318.               OUTPUT-FILE-NAME
  319.               $TR_FILE_TTY_MESSAGESP ))
  320.  
  321. #+cl
  322. (defun maxima-string (symb)
  323.   (string-left-trim "&" (string symb)))
  324.  
  325. #+cl
  326. (defmfun $translate_file (input-file &optional output-file)
  327.       (setq input-file (maxima-string input-file))
  328.       (cond (output-file (setq output-file (maxima-string output-file))))
  329.       (translate-file input-file output-file))
  330.  
  331. (DEFMVAR $TR_GEN_TAGS NIL
  332.      "If TRUE, TRANSLATE_FILE generates a TAGS file for
  333.      use by the text editor")
  334.  
  335. (defvar *pretty-print-translation* t)
  336. #+cl
  337. (defun call-batch1 (in-stream out-stream &aux expr transl)
  338.   (cleanup)
  339.   ;; we want the thing to start with a newline..
  340.   (newline in-stream #\n)
  341.   (sloop while (and (setq  expr      (mread in-stream))
  342.            (consp expr))
  343.     do (setq transl (translate-macexpr-toplevel (third expr)))
  344.     (cond (*pretty-print-translation* (pprint transl out-stream))
  345.           (t
  346.            (format out-stream  "~A" transl)))))
  347.  
  348.  
  349. (defun translate-from-stream (from-stream &key to-stream eval pretty (print-function #'prin1) &aux expr transl )
  350.   (bind-transl-state            
  351.   (sloop while (and (setq expr (mread from-stream)) (consp expr))
  352.     with *in-translate-file* = t
  353.     with *print-pretty* = pretty
  354.     do (setq transl (translate-macexpr-toplevel (third expr)))
  355.     ;(show transl  forms-to-compile-queue)
  356.     (cond (eval (eval transl)))
  357.     (cond (to-stream (funcall print-function transl to-stream)))
  358.     (sloop for v in forms-to-compile-queue
  359.           do (show v to-stream)
  360.           when to-stream
  361.           do (funcall print-function v to-stream)
  362.           when eval
  363.           do (eval v)
  364.           )
  365.     (setq forms-to-compile-queue nil))))
  366.  
  367. (DEFVAR TRF-START-HOOK NIL)
  368.  
  369. #+cl
  370. (DEFUN DELETE-OLD-AND-OPEN (X)
  371.     (open x :direction :output))
  372. #-cl
  373. (DEFUN DELETE-OLD-AND-OPEN (X)
  374.        (IF (LET ((F (PROBE-FILE X)))
  375.         (AND F (NOT (MEMQ (CADDR (NAMELIST F)) '(< >)))))
  376.        (DELETEF X))
  377.        (OPEN-OUT-DSK X))
  378.  
  379. #+cl
  380. (defun alter-pathname (pathname &rest options)
  381.   (apply 'make-pathname :defaults (pathname  pathname)  options))
  382. #+cl
  383. (defun insert-necessary-function-declares (stream)
  384.   (sloop for v in *untranslated-functions-called*
  385.     when (get v 'once-translated)
  386.     do (setq  *untranslated-functions-called*  (delete v *untranslated-functions-called*))
  387.     and
  388.     collecting v into warns
  389.     finally (cond (warns
  390.                (format stream "~2%;;The following functions declaration should ~
  391.                                           ;;go at the front of your macsyma file ~
  392.                                           ~%;;" )
  393.                (mgrind `(($eval_when) $translate (($declare_translated) ,@ warns))
  394.                      stream)
  395.                (format t "~%See the extra declarations at the end of the translated file.  They ~
  396.                      should be included in you macsyma file, and you should retranslate.")))))
  397.  
  398.  
  399. #+cl
  400. (DEFUN TRANSLATE-FILE (IN-FILE-NAME OUT-FILE-NAME
  401.                     &optional
  402.                     (TTYMSGSP  $TR_FILE_TTY_MESSAGESP) &aux  warn-file
  403.                     translated-file
  404.                     *translation-msgs-files* *untranslated-functions-called*)
  405.   (BIND-TRANSL-STATE
  406.     (SETQ *IN-TRANSLATE-FILE* T)
  407.     (setq translated-file (alter-pathname (or out-file-name in-file-name) :type "LISP"))
  408.     (setq warn-file (alter-pathname in-file-name :type "UNLISP"))
  409.     (with-open-file (in-stream in-file-name)
  410.       (with-open-file (out-stream translated-file :direction :output)
  411.     (with-open-file (warn-stream warn-file :direction :output)
  412.           (setq *translation-msgs-files* (list warn-stream))
  413.       (IF TTYMSGSP
  414.           (SETQ *TRANSLATION-MSGS-FILES*
  415.             (CONS *standard-output* *TRANSLATION-MSGS-FILES*)))
  416.       (format out-stream
  417.   ";;; -*- Mode: Lisp; package:maxima; syntax:common-lisp ;Base: 10 -*- ;;;~%")
  418.       #+lispm
  419.       (format out-stream ";;;Translated on: ~A"
  420.           (time:print-current-time nil))
  421.       #+lispm
  422.       (format out-stream
  423.           ";;Maxima System version ~A"
  424.           (or (si:get-system-version 'maxima)
  425.               (si:get-system-version 'cl-maxima)))
  426.       #+cl (format out-stream "~%(in-package \"MAXIMA\")")
  427.       (format warn-stream "~%This is the unlisp file for ~A "
  428.        (namestring (pathname in-stream)))
  429.         (MFORMAT out-stream
  430.            "~%;;** Variable settings were **~%~%")
  431.       (sloop for v in (cdr $tr_state_vars)
  432.         do (mformat out-stream   ";;~:M:~:M;~%" v (symbol-value v)))
  433.       (MFORMAT *terminal-io* "~%Translation begun on ~A.~%"
  434.            (pathname in-stream))
  435.       (CALL-BATCH1 in-stream out-stream)
  436.       (insert-necessary-function-declares out-stream)
  437.       ;; BATCH1 calls TRANSLATE-MACEXPR-toplevel on each expression read.
  438.       (cons '(mlist) 
  439.         (mapcar 'namestring
  440.         (mapcar 'pathname
  441.             (list in-stream out-stream warn-stream)))))))))
  442.  
  443.  
  444. #-cl 
  445. (DEFUN TRANSLATE-FILE (IN-FILE-NAME OUT-FILE-NAME TTYMSGSP)
  446.   (BIND-TRANSL-STATE
  447.    (SETQ *IN-TRANSLATE-FILE* T)
  448.    (LET ((IN-FILE)
  449.      (*TRANSLATION-MSGS-FILES*)
  450.      (DSK-MSGS-FILE)
  451.      (TAGS-OUTPUT-STREAM)
  452.      (TAGS-OUTPUT-STREAM-STATE)
  453.      (WINP NIL)
  454.      (TRUE-IN-FILE-NAME))
  455.      (UNWIND-PROTECT
  456.       (PROGN
  457.        (SETQ IN-FILE  (OPEN IN-FILE-NAME)
  458.          TRUE-IN-FILE-NAME (TO-MACSYMA-NAMESTRING (TRUENAME IN-FILE))
  459.          $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED TRUE-IN-FILE-NAME
  460.          TRANSL-FILE (DELETE-OLD-AND-OPEN
  461.               (MERGEF (trlisp-outputname-temp)
  462.                   OUT-FILE-NAME))
  463.          DSK-MSGS-FILE (DELETE-OLD-AND-OPEN
  464.                 #+cl
  465.                  (merge-pathnames out-file-name
  466.                           (make-pathname :type "unlisp"))
  467.                  #-cl(MERGEF (trcomments-outputname-temp)
  468.                     OUT-FILE-NAME)
  469.                  )
  470.          *TRANSLATION-MSGS-FILES* (LIST DSK-MSGS-FILE))
  471.        (IF $TR_GEN_TAGS
  472.        (SETQ TAGS-OUTPUT-STREAM
  473.          (OPEN-out-dsk (MERGEF (trtags-outputname-temp)
  474.                        IN-FILE-NAME))))
  475.        (IF TTYMSGSP
  476.        (SETQ *TRANSLATION-MSGS-FILES*
  477.          (CONS #-cl TYO #+cl *standard-output* *TRANSLATION-MSGS-FILES*)))
  478.         #-cl(PROGN(CLOSE IN-FILE)
  479.           ;; IN-FILE stream of no use with old-io BATCH1.
  480.            (SETQ IN-FILE NIL))
  481.        (MFORMAT DSK-MSGS-FILE "~%This is the UNLISP file for ~A.~%"
  482.         TRUE-IN-FILE-NAME)
  483.        (MFORMAT *terminal-io* "~%Translation begun on ~A.~%"
  484.         TRUE-IN-FILE-NAME)
  485.        (IF TRF-START-HOOK (FUNCALL TRF-START-HOOK TRUE-IN-FILE-NAME))
  486.        #-cl
  487.        (IF TAGS-OUTPUT-STREAM (TAGS-START//END IN-FILE-NAME))
  488.        (CALL-BATCH1 in-file transl-file)
  489.        ;; BATCH1 calls TRANSLATE-MACEXPR on each expression read.
  490.        (MFORMAT DSK-MSGS-FILE
  491.         "~%//* Variable settings were *//~%~%")
  492.        (DO ((L (CDR $TR_STATE_VARS) (CDR L)))
  493.        ((NULL L))
  494.      (MFORMAT-OPEN DSK-MSGS-FILE
  495.                "~:M:~:M;~%"
  496.                (CAR L) (SYMBOL-VALUE (CAR L))))
  497.        #-cl(RENAME-TF OUT-FILE-NAME TRUE-IN-FILE-NAME)
  498.        #-cl       (WHEN TAGS-OUTPUT-STREAM
  499.          (TAGS-START//END)
  500.          ;;(CLOSE TAGS-OUTPUT-STREAM) 
  501.          (RENAMEF TAGS-OUTPUT-STREAM (trtags-outputname)))
  502.        ;;(CLOSE DSK-MSGS-FILE)
  503.        ;; The CLOSE before RENAMEF clobbers the old temp file.
  504.        ;; nope. you get a FILE-ALREADY-EXISTS error. darn.
  505.        (let ((tr-comment-file-name (mergef (trcomments-outputname)
  506.                    out-file-name)))
  507.      #-cl (if (probe-file tr-comment-file-name)
  508.              (deletef tr-comment-file-name))
  509.     #-cl (RENAMEF DSK-MSGS-FILE tr-comment-file-name)
  510.        (SETQ WINP T)
  511.        #-cl`((MLIST) ,(TO-MACSYMA-NAMESTRING TRUE-IN-FILE-NAME)
  512.          ,(TO-MACSYMA-NAMESTRING OUT-FILE-NAME)
  513.          ,(TO-MACSYMA-NAMESTRING (TRUENAME tr-comment-file-name))
  514.          ,@(IF TAGS-OUTPUT-STREAM
  515.                (LIST (TO-MACSYMA-NAMESTRING
  516.                   (TRUENAME TAGS-OUTPUT-STREAM)))
  517.                NIL))
  518.       #+cl `((mlist) ,(send in-file :truename)
  519.         ,(send transl-file :truename)
  520.         ,(send dsk-msgs-file :truename))))
  521.       ;; Unwind protected. 
  522.       (IF DSK-MSGS-FILE (CLOSE DSK-MSGS-FILE))
  523.       (IF TRANSL-FILE   (CLOSE TRANSL-FILE))
  524.       (if in-file  (close in-file))
  525.       (IF TAGS-OUTPUT-STREAM (CLOSE TAGS-OUTPUT-STREAM))
  526.       (WHEN (AND (NOT WINP) (NOT *TRANSL-FILE-DEBUG*))
  527.         (IF TAGS-OUTPUT-STREAM (DELETEF TAGS-OUTPUT-STREAM))
  528.         (IF TRANSL-FILE (DELETEF TRANSL-FILE)))))))
  529.  
  530.  
  531.  
  532. ;; Should be rewritten to use streams.  Barf -- perhaps SPRINTER doesn't take
  533. ;; a stream argument? Yes Carl SPRINTER is old i/o, but KMP is writing
  534. ;; a new one for NIL.  -GJC
  535.  
  536. (DEFUN PRINT* (P)
  537.   (LET ((^W T)
  538.     (OUTFILES (LIST TRANSL-FILE))
  539.     (^R T)
  540.     #-cl(*NOPOINT NIL)
  541.     ($LOADPRINT NIL)) ;;; lusing old I/O !!!!!
  542.        (declare (special OUTFILES))
  543.     (SUB-PRINT* P)))
  544.  
  545. ;;; i might as well be real pretty and flatten out PROGN's.
  546.  
  547. (DEFUN SUB-PRINT* (P &AUX (FLAG NIL))
  548.   (COND ((ATOM P))
  549.     ((AND (EQ (CAR P) 'PROGN) (CDR P) (EQUAL (CADR P) ''COMPILE))
  550.      (MAPC #'SUB-PRINT* (CDDR P)))
  551.     (T
  552.      (SETQ FLAG (AND $TR_SEMICOMPILE
  553.              (NOT (MEMQ (CAR P) '(EVAL-WHEN INCLUDEF)))))
  554.      (WHEN FLAG (PRINC* '|(PROGN|) (TERPRI*))
  555.      (COND ($COMPGRIND
  556.         (SPRIN1 P))
  557.            (T
  558.         (PRIN1 P TRANSL-FILE)))
  559.      (WHEN FLAG (PRINC* '|)|))
  560.      (TERPRI TRANSL-FILE))))
  561.  
  562. (DEFUN PRINC* (FORM) (PRINC FORM TRANSL-FILE))
  563.  
  564. (DEFUN NPRINC* (&REST FORM)
  565.   (MAPC #'(LAMBDA (X) (PRINC X TRANSL-FILE)) FORM))
  566.  
  567. (DEFUN TERPRI* () (TERPRI TRANSL-FILE))
  568.  
  569. (DEFUN PRINT-MODULE (M)
  570.   (NPRINC* " " M " version " (GET M 'VERSION)))
  571.  
  572. (DEFUN NEW-COMMENT-LINE ()
  573.   (TERPRI*)
  574.   (PRINC* ";;;"))
  575.  
  576. (defun print-TRANSL-MODULEs ()
  577.   (NEW-COMMENT-LINE)
  578.   (PRINT-MODULE 'TRANSL-AUTOLOAD)
  579.   (DO ((J 0 (f1+ J))
  580.        (S (zl-DELETE 'TRANSL-AUTOLOAD (copy-top-level TRANSL-MODULES ))
  581.       (CDR S)))
  582.       ((NULL S))
  583.     (IF (= 0 (fixnum-remainder J 3)) (NEW-COMMENT-LINE))
  584.     (PRINT-MODULE (CAR S))))
  585.  
  586.  
  587. (DEFUN PRINT-TRANSL-HEADER (SOURCE)
  588.   (MFORMAT TRANSL-FILE
  589.        ";;; -*- Mode: Lisp; package:maxima; syntax:common-lisp -*-~%")
  590.   (IF SOURCE
  591.       (MFORMAT TRANSL-FILE ";;; Translated code for ~A" SOURCE)
  592.       (MFORMAT TRANSL-FILE 
  593.            ";;; Translated MACSYMA functions generated by COMPFILE."))
  594.   (MFORMAT TRANSL-FILE
  595.        "~%;;; Written on ~:M, from MACSYMA ~A~
  596.         ~%;;; Translated for ~A~%" 
  597.        ($TIMEDATE) $VERSION (sys-user-id))
  598.   (print-TRANSL-MODULEs)
  599.   (MFORMAT TRANSL-FILE
  600.        ;; The INCLUDEF must be in lower case for transportation
  601.        ;; of translated code to Multics.
  602.        "~%~
  603.        ~%(includef (cond ((status feature ITS) '|DSK:LIBMAX;TPRELU >|)~
  604.        ~%                ((status feature Multics) '|translate|)~
  605.        ~%                ((status feature Unix) '|libmax//tprelu.l|)~
  606.        ~%                (t (MAXIMA-ERROR '|Unknown system, see GJC@MIT-MC|))))~
  607.            ~%~
  608.            ~%(eval-when (compile eval)~
  609.            ~%  (or (status feature lispm)~
  610.        ~%      (setq *infile-name-key*~
  611.        ~%               ((lambda (file-name)~
  612.        ~%                           ;; temp crock for multics.~
  613.        ~%                          (cond ((eq (ml-typep file-name) 'list)~
  614.        ~%                                 (namestring file-name))~
  615.        ~%                                (t file-name)))~
  616.        ~%                  (truename infile)))))~
  617.            ~%~
  618.            ~%(eval-when (compile)~
  619.            ~%   (setq $tr_semicompile '~S)~
  620.            ~%   (setq forms-to-compile-queue ()))~
  621.            ~%~%(comment ~S)~%~%"
  622.             $tr_semicompile source)
  623. (COND ($TRANSCOMPILE
  624.        (UPDATE-GLOBAL-DECLARES)
  625.        (IF $COMPGRIND
  626.        (MFORMAT
  627.         TRANSL-FILE
  628.         ";;; General declarations required for translated MACSYMA code.~%"))
  629.        (PRINT* `(DECLARE . ,DECLARES))))
  630.  
  631. )
  632.  
  633. (DEFUN PRINT-ABORT-MSG (FUN FROM)
  634.   (MFORMAT *TRANSLATION-MSGS-FILES*
  635.        "~:@M failed to Translate.~
  636.             ~%~A will continue, but file output will be aborted."
  637.        FUN FROM))
  638.  
  639. (defmacro extension-filename (x) `(caddr (namelist ,x)))
  640. #-cl
  641. (DEFUN RENAME-TF (NEW-NAME TRUE-IN-FILE-NAME)
  642.   ;; copy the TRANSL-FILE to the file of the new name.
  643.   (let ((IN-FILE))
  644.     (UNWIND-PROTECT
  645.      (PROGN
  646.       (SETQ IN-FILE (OPEN-in-dsk TRANSL-FILE))
  647.       (SETQ TRANSL-FILE
  648.         (OPEN-out-dsk (TRUENAME NEW-NAME)))
  649.       (PRINT-TRANSL-HEADER TRUE-IN-FILE-NAME)
  650.       (MAPC #'PRINT* (NREVERSE *PRE-TRANSL-FORMS*))    ; clever eh?
  651.       (terpri*)
  652.       (PUMP-STREAM IN-FILE TRANSL-FILE)
  653.       (MFORMAT TRANSL-FILE "~%(compile-forms-to-compile-queue)~%~%")
  654.       (DELETEF IN-FILE))
  655.      ;; if something lost...
  656.      (IF IN-FILE (CLOSE IN-FILE))
  657.      (IF TRANSL-FILE (CLOSE TRANSL-FILE)))))
  658.  
  659.  
  660. (DEFUN PUMP-STREAM (IN OUT &optional (n #-cl (lsh -1 -1)
  661.                     #+cl  most-positive-fixnum))
  662.   (declare (fixnum n))
  663.   (DO ((C 0))
  664.       ((ZEROP N))
  665.     (DECLARE (FIXNUM C))
  666.     (SETQ C (+TYI IN -1))
  667.     (IF (= C -1) (RETURN NIL))
  668.     (+TYO C OUT)
  669.     (SETQ N (f1- N))))
  670.          
  671.  
  672.  
  673. (DEFMSPEC $TRANSLATE (FUNCTS) (SETQ FUNCTS (CDR FUNCTS))
  674.   (COND ((AND FUNCTS ($LISTP (CAR FUNCTS)))
  675.      (MERROR "Use the function TRANSLATE_FILE"))
  676.     (T
  677.      (COND ((OR (MEMQ '$FUNCTIONS FUNCTS)
  678.             (MEMQ '$ALL FUNCTS))
  679.         (SETQ FUNCTS (MAPCAR 'CAAR (CDR $FUNCTIONS)))))
  680.      (DO ((L FUNCTS (CDR L))
  681.           (V NIL))
  682.          ((NULL L) `((MLIST) ,@(NREVERSE V)))
  683.        (COND ((ATOM (CAR L))
  684.           (LET ((IT (TRANSLATE-FUNCTION ($VERBIFY (CAR L)))))
  685.             (IF IT (PUSH IT V))))
  686.          (T
  687.           (TR-TELL
  688.            (CAR L)
  689.            " is an illegal argument to TRANSLATE.")))))))
  690.  
  691. #+CL
  692. (PROGN 'COMPILE
  693. (DECLARE-TOP (SPECIAL forms-to-compile-queue))
  694. (DEFMSPEC $COMPILE (FORM)
  695.   (LET ((L (MEVAL `(($TRANSLATE),@(CDR FORM)))))
  696.     (LET ((forms-to-compile-queue ()))
  697.       (MAPC #'(LAMBDA (X) (IF (FBOUNDP X) (COMPILE X))) (CDR L))
  698.       (DO ()
  699.       ((NULL FORMS-TO-COMPILE-QUEUE) L)
  700.     (MAPC #'(LAMBDA (FORM)
  701.           (EVAL FORM)
  702.           (AND (consp FORM)
  703.                (EQ (CAR FORM) 'DEFUN)
  704.                (SYMBOLP (CADR FORM))
  705.                (COMPILE (CADR FORM))))
  706.           (PROG1 FORMS-TO-COMPILE-QUEUE
  707.              (SETQ FORMS-TO-COMPILE-QUEUE NIL)))))))
  708. )
  709.